home *** CD-ROM | disk | FTP | other *** search
/ Software Vault: The Gold Collection / Software Vault - The Gold Collection (American Databankers) (1993).ISO / cdr48 / pas_0593.zip / SORTQ.PAS < prev    next >
Pascal/Delphi Source File  |  1993-05-30  |  6KB  |  165 lines
  1. {─ Fido Pascal Conference ────────────────────────────────────────────── PASCAL ─
  2. Msg  : 493 of 527
  3. From : Alexander Christov                  2:341/34.0           14 May 93  12:42
  4. To   : All
  5. Subj : Sorting Routines (2/3)
  6. ────────────────────────────────────────────────────────────────────────────────
  7. Hi All!}
  8.  
  9. {$A-,B-,D+,E-,F+,G+,I-,L+,N-,O+,P+,Q-,R-,S-,T-,V-,X+,Y+}
  10. { I don't know which settings are really necessary for this unit, but since
  11.   I always work with the above, I'm including them to make sure the unit
  12.   compiles in your computer. The only critical ones (I Think) are R- and F+
  13. }
  14. UNIT SORTQ;
  15. {─────────────────────────────────────────────────────────────────────────}
  16. { Purpose:   Unit that implements a generic QSort, similar to the         }
  17. {            one in the standard C library, but a lot more general        }
  18. {            This new version allows ordering of almost anything,         }
  19. {            even structures whose elements are not contiguous in memory  }
  20. {            or have strange mutual dependancies that don't allow "happy  }
  21. {            swapping". Obviously, this version is slower than the        }
  22. {            previous one. If you won't be sorting Linked Lists or        }
  23. {            Collections, use the previous one.                           }
  24. { Author   : Alexander Christov                                           }
  25. { Notes    : Very instructive on the use of pointers in TP.               }
  26. {            This version does not limit the number of elements to        }
  27. {            65535 since the need not be contiguous.                      }
  28. {                                                                         }
  29. {    Use freely.                                                          }
  30. {                                                                         }
  31. {─────────────────────────────────────────────────────────────────────────}
  32. INTERFACE
  33.  
  34. TYPE CmpFunc=Function(El1,El2:Pointer):Boolean;
  35.      AddrFunc=Function(Base:Pointer;Size,N:LongInt):Pointer;
  36.      SwapProc=Procedure(El1,El2:Pointer;Size:LongInt);
  37.  
  38. Procedure QSort(Base:Pointer;      { Pointer to the first element.
  39.                                      If the user writes his own GT, Addr and
  40.                                      Swap, this isn't really necessary.
  41.                                    }
  42.                 Elements:LongInt;  { Total number of elements }
  43.                 Size:Word;         { Size of an element in bytes }
  44.                 GT:CmpFunc;        { Comparing function  }
  45.                 Addr:AddrFunc;     { Addressing function }
  46.                 Swap:SwapProc);    { Swapping function }
  47.  
  48. {
  49.   GT        - A funcion of type CmpFunc that compares the elements pointed
  50.               to by its first and second arguments, and returns TRUE if the
  51.               first element is Greater Than the second one. This unit defines
  52.               some commonly used CmpFuncs:
  53.                     bGT - Compares BYTEs
  54.                     wGT - Compares WORDs
  55.                     lGT - Compares LONGINTs
  56.                     rGT - Compares REALs
  57.  
  58.   Addr      - A Function that receives the index of an element and must
  59.               return a pointer to it.
  60.               This unit defines the function
  61.                    LinearAddr
  62.               which can be used whenever the elements are located
  63.               contiguously in memory.
  64.  
  65.   Swap      - A Procedure that swaps the elements pointed by its arguments.
  66.                     DirectSwap
  67.               is defined in the unit, which can be used whenever the elements
  68.               are mutually independent or no external processes are needed
  69.               when swapping two elements
  70. }
  71.  
  72. { Commonly used CmpFuncs }
  73.  
  74. Function bGT(El1,El2:Pointer):Boolean;      { Compares ^BYTE }
  75. Function wGT(El1,El2:Pointer):Boolean;      { Compares ^WORD }
  76. Function lGT(El1,El2:Pointer):Boolean;      { Compares ^LONGINT }
  77. Function rGT(El1,El2:Pointer):Boolean;      { Compares ^REAL }
  78.  
  79. Function LinearAddr(Base:Pointer;Size,N:LongInt):Pointer;
  80. Procedure DirectSwap(El1,El2:Pointer;Size:LongInt);
  81.  
  82. IMPLEMENTATION
  83. {$F+}
  84.  
  85. TYPE Dummy=ARRAY[0..0] OF BYTE;
  86.      pDummy=^Dummy;
  87.  
  88.  
  89. VAR X,Middle:Pointer;
  90.  
  91. Procedure
  92. _Sort(Base:Pointer;L,R:LongInt;Size:Word;GT:CmpFunc;Addr:AddrFunc;Swap:SwapProc 
  93. );
  94. VAR I,J:LongInt;
  95. BEGIN
  96.  I:=L;
  97.  J:=R;
  98.  Move(Addr(Base,Size,(L+R) div 2)^,Middle^,Size);
  99.  REPEAT
  100.   While GT(Middle,Addr(Base,Size,I)) DO INC(I);
  101.   While GT(Addr(Base,Size,J),Middle) DO DEC(J);
  102.   IF I<=J THEN BEGIN
  103.    IF I<>J THEN Swap(Addr(Base,Size,I),Addr(Base,Size,J),Size);
  104.    INC(I);
  105.    DEC(J);
  106.   END;
  107.  UNTIL I>J;
  108.  IF L<J THEN _Sort(Base,L,J,Size,GT,Addr,Swap);
  109.  IF I<R THEN _Sort(Base,I,R,Size,GT,Addr,Swap);
  110. END;
  111.  
  112. Procedure QSort;
  113. BEGIN
  114.  GetMem(X,Size);  { <- Made in Arturo Ramirez 8-) }
  115.  GetMem(Middle,Size);
  116.  _Sort(Base,0,Elements-1,Size,GT,Addr,Swap);
  117.  FreeMem(X,Size);
  118.  FreeMem(Middle,Size);
  119. END;
  120.  
  121. Function bGT(El1,El2:Pointer):Boolean;
  122. TYPE pByte=^Byte;
  123. BEGIN
  124.  bGt:=(pByte(El1)^>pByte(El2)^);
  125. END;
  126.  
  127. Function wGT(El1,El2:Pointer):Boolean;
  128. TYPE pWord=^Word;
  129. BEGIN
  130.  wGt:=(pWord(El1)^>pWord(El2)^);
  131. END;
  132.  
  133. Function lGT(El1,El2:Pointer):Boolean;
  134. TYPE pLongint=^Longint;
  135. BEGIN
  136.  lGt:=(pLongInt(El1)^>pLongInt(El2)^);
  137. END;
  138.  
  139. Function rGT(El1,El2:Pointer):Boolean;
  140. TYPE pReal=^Real;
  141. BEGIN
  142.  rGt:=(pReal(El1)^>pReal(El2)^);
  143. END;
  144.  
  145. { Linear Addressing }
  146.  
  147. Function LinearAddr;
  148. BEGIN
  149.  LinearAddr:=@pdummy(Base)^[N*Size];
  150. END;
  151.  
  152. { Direct swapping of elements. With the use of Addr() it is quite more
  153.  legible 8-) }
  154.  
  155. Procedure DirectSwap;
  156. VAR Tmp:Pointer;
  157. BEGIN
  158.  GetMem(Tmp,Size);
  159.  Move(El1^,Tmp^,Size);
  160.  Move(El2^,El1^,Size);
  161.  Move(Tmp^,El2^,Size);
  162.  FreeMem(Tmp,Size);
  163. END;
  164.  
  165. END.